home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
lists.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
4KB
|
179 lines
/* ******************************************************************** */
/* lists.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* basic list operations */
/* ******************************************************************** */
#define JMPDBG(x)
/*
* Change Log:
* Version 1, March 1990 (Compiler rationalisation)
* Verified GC proof.
*/
#include <string.h>
#include "funcalls.h"
#include "defs.h"
#include "structs.h"
#include "error.h"
#include "global.h"
#include "allocate.h"
#include "modboot.h"
EUFUN_1( Fn_consp, form)
{
return (is_cons(form) ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_car, x)
{
while (TRUE) {
if (is_cons(x)) return (x->CONS).car;
/* Illegal car; needs to act on signals */
/* Until that is fixed just stop */
x = CallError(stacktop,"car: ~a is not list",x,CONTINUABLE);
}
return(nil); /* dummy */
}
EUFUN_CLOSE
EUFUN_2( car_updator, x, y)
{
while (!is_cons(x))
x = CallError(stacktop,"car_updator: attempt to rplaca into atom ~a", x,
CONTINUABLE);
(x->CONS).car = y;
return y;
}
EUFUN_CLOSE
EUFUN_1( Fn_cdr, x)
{
while (TRUE) {
if (is_cons(x)) return (x->CONS).cdr;
/* Illegal car; needs to act on signals */
/* Until that is fixed just stop */
x = CallError(stacktop,"cdr: ~a is not list",x,CONTINUABLE);
}
return(nil); /* dummy */
}
EUFUN_CLOSE
EUFUN_2( cdr_updator, x, y)
{
while (!is_cons(x))
x = CallError(stacktop,"cdr_updator: attempt to rplacd into atom ~a", x,
CONTINUABLE);
(x->CONS).cdr = y;
return y;
}
EUFUN_CLOSE
/* Length of a list; does not check */
EUFUN_1( Fn_length, form)
{
int i = 0;
while (is_cons(form)) {
i++;
form = CDR(form);
}
return allocate_integer(stacktop,i);
}
EUFUN_CLOSE
EUFUN_1( Fn_list, ll)
{
/* Say, wow!! Declaring this n-ary gives us it for free... */
return(ll);
}
EUFUN_CLOSE
/* For no readily apparent reason... */
EUFUN_3( Sf_tilnil, mod, env, forms)
{
extern LispObject Sf_progn(LispObject*);
while (Sf_progn(stackbase) != nil);
return(nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_list_to_string, l)
{
char buf[512];
LispObject walker,str;
walker = l; buf[0] = '\0';
while (is_cons(walker)) {
if (!is_symbol(CAR(walker)))
CallError(stacktop,
"string-to-list: non-symbol in list",l,NONCONTINUABLE);
strcat(buf,CAR(walker)->SYMBOL.pname);
walker = CDR(walker);
}
str = (LispObject) allocate_string(stacktop,buf,strlen(buf));
return(str);
}
EUFUN_CLOSE
/*
* Module initialisation...
*/
#define LISTS_ENTRIES 11
MODULE Module_lists;
LispObject Module_lists_values[LISTS_ENTRIES];
void initialise_lists(LispObject* stacktop)
{
extern LispObject generic_generic_convert;
LispObject get,set;
open_module(stacktop,
&Module_lists,
Module_lists_values,
"lists",
LISTS_ENTRIES);
(void) make_module_function(stacktop,"consp",Fn_consp,1);
(void) make_module_function(stacktop,"cons",Fn_cons,2); /* In allocate.c */
get = make_module_function(stacktop,"car",Fn_car,1);
STACK_TMP(get);
set = make_unexported_module_function(stacktop,"car-updator",car_updator,2);
UNSTACK_TMP(get);
set_anon_associate(stacktop,get,set);
get = make_module_function(stacktop,"cdr",Fn_cdr,1);
STACK_TMP(get);
set = make_unexported_module_function(stacktop,"cdr-updator",cdr_updator,2);
UNSTACK_TMP(get);
set_anon_associate(stacktop,get,set);
(void) make_module_function(stacktop,"list-length",Fn_length,1);
(void) make_module_function(stacktop,"list",Fn_list,-1);
(void) make_module_special(stacktop,"tilnil",Sf_tilnil);
(void) make_module_function(stacktop,"list-to-string",Fn_list_to_string,1);
(void) make_module_function(stacktop,"generic_generic_convert,Cons,String",
Fn_list_to_string,2
);
close_module();
}